Chapter 12
Code example 12-1
'------------------------------------------------------------
' DeleteSrVol
'
'------------------------------------------------------------
Function DeleteSrVol()
On Error GoTo DeleteSrVol_Err

    If (MsgBox("Do you mean to delete this SrVol?", 291, _
"Delete SrVol")) Then
        ' Deletes the record if user responds Yes.
        DoCmd.CancelEvent
    End If

DeleteSrVol_Exit:
    Exit Function

DeleteSrVol_Err:
    MsgBox Error$
    Resume DeleteSrVol_Exit
End Function
Code example 12-2
Private Sub Form_BeforeUpdate(Cancel As Integer)
Dim strMsg As String
Dim bytResponse As Byte
'Test both LastName and email values for blanks.

If Not IsNull(LastName) And IsNull(email) Then
    strMsg = "Are you sure there is no e-mail address?"
    bytResponse = MsgBox(strMsg, vbQuestion + vbOKCancel, _
        "No E-mail?")
    If bytResponse = vbCancel Then
    'You have clicked the Cancel button.
        email.SetFocus      'Return to the email control
        Cancel = True       'Cancel saving the record
    End If
End If
End Sub
Code example 12-3
Public Function ErrorMessage(ErrorNo As Integer)
'This is a function that generates a message box with a
'custom error message. It uses a select case structure and
'a DLookup function to produce the text string description.
   
On Error GoTo ErrorMessage_Err:
Dim strErrDesc As String

Select Case ErrorNo          'Branches to custom error number

Case 3120
    strErrDesc = DLookup("ErrDesc", "tblErrors", & _
"ErrNumber =" & ErrorNo)

Case 3135
    strErrDesc = DLookup("ErrDesc", "tblErrors", & _
"ErrNumber =" & ErrorNo)

Case 3170
    strErrDesc = DLookup("ErrDesc", "tblErrors", _
"ErrNumber =" & ErrorNo)

Case 3320
    strErrDesc = DLookup("ErrDesc", "tblErrors", _
"ErrNumber =" & ErrorNo)

End Select

MsgBox "The following error Occurred " & ErrorNo & _
" " & strErrDesc , vbCritical, "Run-time error"

Exit_This_Function:
    Exit Function

ErrorMessage_Err:
    If Err.Number <> 0 Then
        MsgBox Err.Number & " " & Err.Description
    End If
    Resume Exit_This_Function
End Function
Code example 12-4
Public Function GetAmountOwed() As Currency
On Error GoTo GetInvoiceNumber_Err:
   
'This function allows a user to enter a client ID number
'which looks up and adds the total amount of all invoices
'owed to date.
'The result is then returned.
   
Dim dbs As Database
Dim rst As Recordset
Dim strInputString As String
Dim strSQL As String
   
strInputString = InputBox("Please enter the client's " _
       & "ID number.", "Accounts Payable by client ID")
   
strSQL = "SELECT Sum(tblTimeItemize.JobRate) AS SumOfJobRate " _
       & "FROM tblTimeItemize _
& "GROUP BY tblTimeItemize.ClientNo " _
       & "HAVING tblTimeItemize.ClientNo ='" _
& strInputString & "';"

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)

'The total amount is rounded to two decimal places.
GetAmountOwed = Round(rst!SumOfJobRate, 2)
   
rst.Close
dbs.Close
Exit_This_Function:
    Exit Function   

GetInvoiceNumber_Err:
    If Err.Number <> 0 Then
        MsgBox Err.Number & " " & Err.Description
    End If
    Resume Exit_This_Function
End Function
Code example 12-5
Private Sub Build_Form_Click()
Dim frm As Form
Dim ctlField1 As Control, ctlField2 As Control, ctlField3 As Control

Set frm = CreateForm
frm.RecordSource = "SELECT SrVols.LastName, SrVols.FirstName, " & _
    "SrVols.email FROM SrVols WHERE (((SrVols.email) Is Not Null));"
DoCmd.Restore
With frm
    .DefaultView = 1    'Continuous form view
    .Caption = "Email Addresses"
    .PopUp = True
    .Modal = True
    .AllowFormView = True
    .AllowDatasheetView = True
    .AllowPivotChartView = False
    .AllowPivotTableView = False
    .DividingLines = False
    .Width = 4600
    .AutoResize = True
    .AutoCenter = True
    .BorderStyle = 3
    .ControlBox = True
    .MinMaxButtons = 0
End With

frm.Section(acDetail).Height = 300
Set ctlField1 = CreateControl(frm.Name, acTextBox, acDetail, _
    "Last Name", "LastName", 100, 50, 2200)
Set ctlField2 = CreateControl(frm.Name, acTextBox, acDetail, _
    "First Name", "FirstName", 2880, 50, 2200)
Set ctlField3 = CreateControl(frm.Name, acTextBox, acDetail, _
    "Email Address", "email", 5760, 50, 2200)
DoCmd.Restore
DoCmd.OpenForm frm.Name, acNormal

End Sub
Code example 12-6
Private Sub btnMove_Click()
'Moves selected name to the Sent list.
On Error GoTo btnMoveErr:

Dim dbs As Database
Dim rst As Recordset
Dim strSQL As String

'List3 is the name of the Members List list box control.
'List14 is the name of the SendTo List list box control.
strSQL = "SELECT * FROM EmployeeSalesSummary WHERE FullName = '" & _
    List3.Value & "'"

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)

'Loop through the list and set the Selected property to True
With rst
    .Edit
    !Selected = True
    .Update
End With

'Update both lists.
Me.List14.Requery
Me.List3.Requery

btnMoveExit:
    Exit Sub

btnMoveErr:
If Err.Number <> 0 Then
    MsgBox Err.Number & " " & Err.Description
End If
Resume btnMoveExit
End Sub
Code example 12-7
Private Sub btnRemove_Click()
'Removes selected name from Send To list.

On Error GoTo btnRemoveErr:

Dim dbs As Database
Dim rst As Recordset
Dim strSQL As String

strSQL = "SELECT * FROM EmployeeSalesSummary WHERE FullName = '" & _
    List14.Value & "'"

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)

With rst
    .Edit
    !Selected = False
    .Update
End With

'Update both list boxes.
Me.List14.Requery
Me.List3.Requery

btnRemoveExit:
    Exit Sub
   
btnRemoveErr:
If Err.Number <> 0 Then
    MsgBox Err.Number & " " & Err.Description
End If
Resume btnRemoveExit

End Sub
Code example 12-8
Private Sub btnSend_Click()
'This is a send button that sends the annual sales figures report
'to the people listed in the distribution box.
Dim rst As Recordset
Dim dbs As Database
Dim strSQL As String
Dim strSendTo As String
Dim strStatement As String

'Add all names that have been selected to the distribution list.

strSQL = "SELECT * FROM EmployeeSalesSummary WHERE Selected = True"
strStatement = "Here is the Sales Summary Report for the " & _
"annual sales figures"

'Set database and record set then empty the SendTo list
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)
strSendTo = ""

'Loop until all distributions' emails have been listed.

Do Until rst.EOF
    strSendTo = strSendTo & rst!FName & rst!LName & _
"@OurSales.com; "
    rst.MoveNext
Loop

'Send report to employees of the list.

DoCmd.SendObject acSendReport, "Sales Summary", "HTML", _
    strSendTo, , , "Annual Sales Report", strStatement
End Sub
Code example 12-9
Private Sub Form_Template_Click()
Dim frm As Form

'Create a new form based on the SrVols form
Set frm = CreateForm(, "Volunteers")
DoCmd.Restore

'Set RecordSource property to SrVols table
frm.RecordSource = "SrVols"
End Sub
Code example 12-10
Private Sub Form_Load()
Dim ctl As Control
Dim intNum As Integer, intEdit As Integer
Const conClear = 0
Const conBlue = 16711680
Const conWhite = 16777215
Const conRed = 255
Const conTransparent = 0
Const conDialog = 2
Const conYellow = 8454143

Me.FormHeader.BackColor = conYellow

For Each ctl In Me.Controls
    With ctl
           Select Case .ControlType
                Case acLabel
                    .SpecialEffect = acEffectShadow
                    .BorderStyle = conDialog
                    .BackColor = conBlue
                    .ForeColor = conRed
                     intEdit = True
                Case acTextBox
                     .SpecialEffect = acEffectNormal
                     .BackColor = conWhite
                     .ForeColor = conBlue
                     .BorderStyle = conTransparent
                     intEdit = True
            End Select
    End With
Next ctl
End Sub

Access Power Programming with VBA, 9/12/2003, Web code examples
Virginia Andersen


